home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swaga_c.zip / COMM.SWG / 0011_Another AVATAR Routine.pas < prev    next >
Pascal/Delphi Source File  |  1993-05-28  |  5KB  |  209 lines
  1. {
  2. GREGORY P. SMITH
  3.  
  4. Here's a Unit I just pieced together from some old code I wrote a couple
  5. years ago.  It'll generate AVT/0+ and ANSI codes:
  6. }
  7.  
  8. Unit TermCode;  {$S-,D-,L-,R-,F-,O-}
  9. {  Generate ANSI and AVT/0+ codes For color and cursor ctrl }
  10. {  Public Domain -- by Gregory P. Smith  }  { untested }
  11.  
  12. Interface
  13.  
  14. Type
  15.   Str12 = String[12];  { Maximum size For most ANSI Strings }
  16.   Str3  = String[3];
  17.   grTermType = (TTY, ANSI, AVT0); { TTY, ANSI or Avatar/0+ }
  18.  
  19. Var
  20.   grTerm : grTermType;
  21.   grColor : Byte;  { Last color set }
  22.  
  23. { Non Specific Functions }
  24. Function grRepChar(c:Char;n:Byte): String;   { Repeat Chars }
  25. Function grSetPos(x,y:Byte): Str12;   { Set Cursor Position }
  26. Function grCLS: Str12;          { Clear Screen + reset Attr }
  27. Function grDelEOL: Str12;                   { Delete to EOL }
  28.  
  29. Function grSetAttr(a:Byte): Str12;      { Change writing color }
  30. Function grSetColor(fg,bg:Byte): Str12; { Change color fg & bg }
  31.  
  32. { AVT/0+ Specific Functions }
  33. Function AVTRepPat(pat:String;n:Byte): String; { Repeat Pattern (AVT/0+) }
  34. Function AVTScrollUp(n,x1,y1,x2,y2:Byte): Str12;
  35. Function AVTScrollDown(n,x1,y1,x2,y2:Byte): Str12;
  36. Function AVTClearArea(a,l,c:Byte): Str12;
  37. Function AVTInitArea(ch:Char;a,l,c:Byte): Str12;
  38.  
  39. Implementation
  40.  
  41. Const
  42.   hdr = #27'['; { ansi header }
  43.  
  44. { Misc support Functions }
  45.  
  46. Function bts(x:Byte): str3; { Byte to String }
  47. Var
  48.   z: str3;
  49. begin
  50.   Str(x,z);
  51.   bts := z;
  52. end;
  53.  
  54. Function Repl(n:Byte; c:Char): String;
  55. Var
  56.   z : String;
  57. begin
  58.   fillChar(z[1],n,c);
  59.   z[0] := chr(n);
  60.   repl := z;
  61. end;
  62.  
  63. { Cursor Control Functions }
  64.  
  65. Function grRepChar(c:Char;n:Byte): String;
  66. begin
  67.   if grTerm = AVT0 then
  68.     grRepChar := ^Y+c+chr(n)
  69.   else
  70.     grRepChar := repl(n,c);
  71. end; { repcahr }
  72.  
  73. Function grSetPos(x,y:Byte): Str12;
  74. begin
  75.   Case grTerm of
  76.     ANSI : if (x = 1) and (y > 1) then
  77.              grSetPos := hdr+bts(y)+'H'   { x defualts to 1 }
  78.            else
  79.              grSetPos := hdr+bts(y)+';'+bts(x)+'H';
  80.     AVT0 : grSetPos := ^V+^H+chr(y)+chr(x);
  81.     TTY  : grSetPos := '';
  82.   end; { Case }
  83. end;
  84.  
  85.  
  86. Function grCLS: Str12;
  87. begin
  88.   Case grTerm of
  89.     ANSI : grCLS := hdr+'2J';
  90.     TTY,
  91.     AVT0 : grCLS := ^L;
  92.   end;
  93.   if grTerm = AVT0 then GrColor := 3; { reset the color }
  94. end; { cls }
  95.  
  96. Function grDelEOL: Str12; { clear rest of line }
  97. begin
  98.   Case grTerm of
  99.     ANSI : grDelEOL := hdr+'K';
  100.     AVT0 : grDelEOL := ^V^G;
  101.     TTY  : grDelEOL := '';
  102.   end;
  103. end;
  104.  
  105. { Color Functions }
  106.  
  107. Function grSetAttr(a:Byte): Str12;
  108. Const
  109.   ANS_Colors : Array[0..7] of Char = ('0','4','2','6','1','5','3','7');
  110. Var
  111.   tmp : Str12;
  112. begin
  113.   tmp := '';
  114.   Case grTerm of
  115.     ANSI :
  116.     begin
  117.       tmp := hdr;
  118.       if (a and $08)=8 then tmp := tmp+'1' else tmp := tmp+'0'; { bright }
  119.       if (a and $80)=$80 then tmp := tmp+';5';  { blink }
  120.       tmp := tmp+';3'+ANS_Colors[a and $07]; { foreground }
  121.       tmp := tmp+';4'+ANS_Colors[(a shr 4) and $07]; { background }
  122.       grSetAttr := tmp+'m'; { complete ANSI code }
  123.     end;
  124.     AVT0 :
  125.     begin
  126.       tmp := ^V+^A+chr(a and $7f);
  127.       if a > 127  then tmp := tmp+^V+^B; { Blink }
  128.       grSetAttr := tmp;
  129.     end;
  130.     TTY  : grSetAttr := '';
  131.   end; { Case }
  132.   GrColor := a; { Current Attribute }
  133. end; { setattr }
  134.  
  135. Function grSetColor(fg,bg:Byte): Str12;
  136. begin
  137.   grSetColor := grSetAttr((bg shl 4) or (fg and $0f));
  138. end; { SetColor }
  139.  
  140. { AVATAR Specific Functions: }
  141.  
  142. Function AVTRepPat(pat:String;n:Byte): String; { Repeat Pattern (AVT/0+) }
  143. begin
  144.   AVTRepPat := ^V+^Y+pat[0]+pat+chr(n); { Repeat pat n times }
  145. end;
  146.  
  147. Function AVTScrollUp(n,x1,y1,x2,y2:Byte): Str12;
  148. begin
  149.   AVTScrollUp := ^V+^J+chr(n)+chr(y1)+chr(x1)+chr(y2)+chr(x2);
  150. end; { AVTScrollUp }
  151.  
  152. Function AVTScrollDown(n,x1,y1,x2,y2:Byte): Str12;
  153. begin
  154.   AVTScrollDown := ^V+^K+chr(n)+chr(y1)+chr(x1)+chr(y2)+chr(x2);
  155. end; { AVTScrollDown }
  156.  
  157. Function AVTClearArea(a,l,c:Byte): Str12;
  158. Var
  159.   b:Byte;
  160.   s:Str12;
  161. begin       { Clear lines,columns from cursor pos With Attr }
  162.   b := a and $7f;
  163.   s := ^V+^L+chr(b)+chr(l)+chr(c);
  164.   if a > 127 then
  165.     Insert(^V+^B,s,1); { blink on }
  166.   AVTClearArea := s;
  167.   GrColor := a;
  168. end; { AVTClearArea }
  169.  
  170. Function AVTInitArea(ch:Char;a,l,c:Byte): Str12;
  171. Var
  172.   b:Byte;
  173.   s:Str12;
  174. begin
  175.   b := a and $7f;
  176.   s := ^V+^M+chr(b)+ch+chr(l)+chr(c);
  177.   if a > 127 then
  178.     Insert(^V+^B,s,1);
  179.   AvtInitArea := s;
  180.   GrColor := a;
  181. end; { AVTInitArea }
  182.  
  183. { Initalization code }
  184. begin
  185.   GrTerm  := AVT0;  { Default to Avatar }
  186.   GrColor := 3;     { Cyan is the AVT/0+ defualt }
  187. end.
  188.  
  189. {
  190. set GrTerm to whatever terminal codes you want to create; then you can use the
  191. common routines to generate ANSI or Avatar codes.  Here's a Print Procedure
  192. that you were mentioning:
  193. }
  194.  
  195. Procedure Print(Var msg:String);
  196. Var
  197.   idx : Byte
  198. begin
  199.   if length(msg) > 0 then
  200.     For idx := 1 to length(msg) do begin
  201.       Parse_AVT1(msg[idx]);
  202.       SendOutComPortThingy(msg[idx]);
  203.     end; { For }
  204. end;
  205. {
  206. You could modify this so that it pays attention to the TextAttr Variable of the
  207. Crt Unit if you wish so that it compares TextAttr to GrColor and adds a
  208. SetAttr(TextAttr) command in before it sends msg.
  209. }